Magnum One/Magnum One (Mid-American Digital) (Disc Manufacturing).iso/d18/ffind.arc/FFIND.PAS

Pascal/Delphi Source File | 1991-04-28 | 12.7 KB | 609 lines

{ Copyright (c) 1989 by Chris Thompson  (CompuServe 76367,106) }

program FFind;

{  Usage:  FFind [d:] [filemask] /switches  }

{  note:   FFIND /H will provide a help screen}

{$M 32768,0,0}
{A+ Align Data}
{B- Boolean Expressions}
{$I- I/O Checking}
{$R- Range Checking}
{$S- Stack Checking}
{$D- Debug Info}
{$L- Local symbols}
{$N- Emulator}
{$V- Var String Checking}

{ Note - this program is coded for maximum readability,  }
{        reliability, and maintainability, not           }
{        for fastest possible execution speed.           }

{        Screen I/O speed is also limited by maintaining }
{        support for DOS redirection of output.          }

{ 1.1    first general release }
{ 1.2    simplified IntToCommaStr algorithm 2/23/89 }
{        simplified String conversion routines }

uses Crt,Dos;

const

  MonthStr: array[1..12] of string[3] = (
    'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
    'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');

  DayStr: array[0..6] of string[3] =
   ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');

type

  TargetStr = String[12];
  DriveStr = String;
  Str3 = String[3];
  Str2 = String[2];

var

  PgmName: String[8];

  Prn: Text;
  Con: Text;

  FoundCount: Integer;
  TotalBytes: Longint;
  Col : Integer;

  LineCount: Byte;

  DriveLetter: String;
  TargetFile: TargetStr;
  SaveDir: DirStr;
  DummyDir: DirStr;
  DummyName: NameStr;
  DummyExt: ExtStr;

  PauseMode,
  PrintingDirs,
  WideDir : Boolean;

  savedExitProc: Pointer;


procedure FindFiles(Dir:PathStr;Target:TargetStr); forward;


function UpperCase (InpStr:String) : String;
{Convert a string to Uppercase}
var
  i: integer;
begin
  for i:= 1 to length(InpStr) do
    InpStr[i]:=UpCase(InpStr[i]);
  UpperCase:=InpStr;
end;

function LoCase(InChar:char): char;
{ convert a Character to lower case }
begin
   if InChar in ['A'..'Z'] then
      LoCase := Chr(ord(InChar)+32)
   else
      LoCase := InChar;
end;


function LowerCase(InpStr:string):string;
{ convert a String to lower case Characters }
var
   i : integer;
begin
   for i := 1 to Length(InpStr) do
     LowerCase[i] := LoCase(InpStr[i]);
   LowerCase[0] := InpStr[0]
end;


function NumStr(N:longint;D:Integer): String;
{Integer to String with Leading Zeros D places wide}
begin
  NumStr[0] := Chr(D);
  while D > 0 do
    begin
      NumStr[D] := Chr(N mod 10 + Ord('0'));
      N := N div 10;
      Dec(D);
    end;
end;

function IntToCommaStr(N:longint): String;
{Comma string from any + or - integer}
const
  s: byte = 0;
var
  W: string[11];
  i: byte;
  d: byte;

begin
  Str(N,W);
  if W[1] = '-' then s := 1;
  d := Length(W);
  for i := 3 to (d-1-s) do
    if i mod 3 = 0 then
      Insert(',',W,(d-I+1+s));
  IntToCommaStr := W;
end;


procedure XHour(HourMil:Integer; var HourCiv :Integer; var ampm : Str2);
begin
  if HourMil > 11 then
    ampm := 'pm'
  else
    ampm := 'am';

  Case HourMil of
    0:     HourCiv := 12;
    1..12: HourCiv := HourMil;
    else   HourCiv := HourMil-12;
  end;

end;


procedure FlushKbd;
var
   Ch: Char;
begin
   If KeyPressed then
     repeat
       Ch := ReadKey;
       If Ch =  #0 then Ch := ReadKey;
       If Ch =  #3 then Halt(0);
       If Ch = #27 then Halt(0);
     until (not KeyPressed);
end;


procedure BackSpace(var f:text;n:longint);
begin
  while n > 0 do
    begin
      Write(Con,#8,' ',#8);
      Dec(n);
    end;
end;


procedure WaitForKeyPress;
begin
  repeat
  ;
  until KeyPressed;
end;


function DayNumber(FilDate:DateTime): word;
var
  SysDate:DateTime;
  DayofWeek: word;
begin
  with SysDate do GetDate(Year, Month,Day,DayofWeek);{save system date }
  with FilDate do SetDate(Year,Month,Day);      {set sys date from file}
  with FilDate do GetDate(Year,Month,Day,DayofWeek);{get DoW from sys  }
  with SysDate do SetDate(Year,Month,Day);          {restore sys date  }
  DayNumber := DayofWeek;
end;


procedure Pause;

const
  Msg = 'Program paused; press any key to continue...';

begin
  FlushKbd;
  Write(Con,Msg);
  WaitForKeyPress;
  FlushKbd;
  BackSpace(Con,Length(Msg));
  LineCount := 1;
end;


procedure NewLine(var f:Text);
begin
  WriteLn(f);
  Col := 0;
  If PauseMode then
   begin
     LineCount := LineCount+1;
     If LineCount > 24 then
       Pause;
   end;
end;

procedure Beep;
begin
  Sound(880);
  Delay(50);
  NoSound;
end;


procedure WriteHelp;
begin
   WriteLn(Prn);
   WriteLn(Prn,'Usage: ',PgmName,' [d:] [filespec] [switches] ');
   WriteLn(Prn);
   WriteLn(Prn,'[d:]       is the drive to search; if this is not');
   WriteLn(Prn,'           specified, the default drive is used');
   WriteLn(Prn);
   WriteLn(Prn,'[filespec] is optional; if omitted, *.* is used');
   WriteLn(Prn);
   WriteLn(Prn,'Switches:');
   WriteLn(Prn);
   WriteLn(Prn,'  /W  Wide format');
   WriteLn(Prn,'  /O  Omit directories');
   WriteLn(Prn,'  /P  Pause Mode');
   WriteLn(Prn,'  /H  Help');
   WriteLn(Prn);
   WriteLn(Prn,'Output may be redirected to a file or device, e.g:');
   WriteLn(Prn);
   WriteLn(Prn,'     >LPT1:');
   WriteLn(Prn,'or');
   WriteLn(Prn,'     >fname.ext');
 end;


{$F+} procedure ProgramExit; {$F-}
begin
    If (errorAddr <> nil) then
     begin
      WriteLn('Program Failed; ExitCode= ',exitcode);
     end
   else if (exitCode <> 0) then
      begin
        WriteLn(Con);
        case ExitCode of
            1: WriteLn(Con,'Invalid FileSpec');
            2: WriteLn(Con,'Invalid Parameter');
        end;
      end;

   Close(Prn);
   Close(Con);

   exitProc := savedExitProc;
end;


procedure PrintTotals;
begin
  If Col > 0 then
    NewLine(Prn);
  NewLine(Prn);
  If FoundCount <= 0 then
    begin
      Write(Prn,'no files found');
      NewLine(Prn);
     end;
  NewLine(Prn);
  Write(Prn,'Files found: ',IntToCommaStr(FoundCount));
  NewLine(Prn);
  Write(Prn,'Total bytes: ',IntToCommaStr(TotalBytes));
  NewLine(Prn);
  Write(Prn,'Drive ',DriveLetter,': ',
            'bytes free: ',
             IntToCommaStr(DiskFree(Ord(DriveLetter[1])-64)));
  NewLine(Prn);
  Beep;
end;


procedure InitPgm;

begin

  SetCBreak(True);
  CheckBreak := False;

  savedExitProc := exitProc;
  exitProc := @ProgramExit;

  Assign(Prn,'');
  Rewrite(Prn);

  AssignCrt(Con);
  Rewrite(Con);

  LineCount := 1;
  FoundCount := 0;
  TotalBytes := 0;
  Col := 0;
  SaveDir := '';

end;


procedure GetCommand;
var
  I: Integer;
  S: PathStr;
  D: DirStr;
  N: NameStr;
  E: ExtStr;

begin
  PauseMode := False;
  WideDir := False;
  PrintingDirs := True;
  DriveLetter := '';
  TargetFile := '';

  if Lo(DosVersion) >= 3 then
    begin
      FSplit(ParamStr(0), D,N,E);
      PgmName := UpperCase(N);
    end
  else PgmName := 'FFIND';

  NewLine(Con);
  Write(Con,PgmName,'-',
              'File Find Ver 1.2 (C) Copyright 1989 C.C. Thompson');
  NewLine(Con);

  for I := 1 to ParamCount do
  begin
    S := ParamStr(I);
    if S[1] = '/' then
      begin
        if Length(S) > 1 then
          case UpCase(S[2]) of
            'W': WideDir := True;
            'O': PrintingDirs := False;
            'P': PauseMode := True;
            'H': begin
                   WriteHelp;
                   Halt(0);
                 end;
           else Halt(2);
          end {Case}
       else;
      end  {S[1] = /}
    else   {must either be drive or filespec}
      if ((Length(S) = 2) and (S[2] = ':')) then
         DriveLetter := UpCase(S[1])
      else TargetFile := Copy(S,1,13);
  end;

  FlushKbd;

  If DriveLetter = '' then
    DriveLetter := Copy(FExpand(''),1,1);

  FSplit(TargetFile,DummyDir,N,E);

  if N = '' then
    if ((E = '.') or (E = '..')) then
       Halt(1)
    else N := '*';

  if E = '' then E := '.*';

  TargetFile := N + E;

  if DummyDir <> '' then
    begin
      NewLine(Con);
      Write(Con,'The path ',DummyDir, ' is ignored');
      NewLine(Con);
    end;

   NewLine(Con);
   Write(Prn,' ':8,'Filespec ', DriveLetter + ':\'+TargetFile,
                   ' used for search');
   NewLine(Prn);

 end;


procedure PrintEntry(Dir:DirStr; FileData:SearchRec);
var
    N: NameStr;
    E: ExtStr;
    T: DateTime;
    ampm: Str2;
    THour: Integer;
    FSize: String;

begin

  if Col > 4 then
    begin
      NewLine(Prn);
      Col := 0;
    end;

  if Dir <> SaveDir then
    begin
      SaveDir := Dir;
      if Col > 0 then
        NewLine(Prn);
      NewLine(Prn);
      Write(Prn,Dir);
      NewLine(Prn);
    end;


  with FileData do
    begin

      if ((Attr and Directory) or (Attr and VolumeID) = 0) then
        Name := LowerCase(Name);

      FSplit(Name,DummyDir,N,E);

      if (Attr and VolumeID) <> 0 then
        begin
          if Col > 0 then
            NewLine(Prn);
          NewLine(Prn);
          Write(Prn,' ':8,'Volume ',N,' ':6,'created');
          SaveDir := '';
        end
      else
        begin
          if WideDir then
            begin
              Write(Prn,' ':2,N+E, ' ':(13 - Length(N+E)));
              Col := Col + 1;
              Exit;
            end
          else
            begin
              Write(Prn,' ':8,N,E,
                        ' ':(13 - (Length(N)+Length(E))));
              if (Attr and Directory) = 0 then
                begin
                  FSize := IntToCommaStr((Size));
                  Write(Prn,'':9-Length(FSize),FSize,' bytes  ')
                end
              else
                Write(Prn,' ':6,'<DIR>',' ':6);
            end;
        end;
        UnpackTime(Time, T);
        XHour(T.Hour,THour, ampm);
        Write(Prn,
              THour: 4, ':',
              NumStr(T.Min, 2), ' ',
              ampm, '  ',
              DayStr[DayNumber(T)],' ',
              MonthStr[T.Month], ' ',
              T.Day:2,' ',
              NumStr(T.Year mod 100, 2));
        NewLine(Prn);
    end; {with FileData}
end;

procedure DosErrorExit;

begin
  NewLine(Con);
  case DosError of
          3: Write(Con,'Invalid drive specification ');
   151..163: case DosError of
              152: Write(Con,'Unable to read From drive ',DriveLetter);
              162: Write(Con,'General Failure on drive ',DriveLetter);
              else Write(Con,'Critical Error ',DosError);
            end;
   else Write(Con,'Error ',DosError,' Program terminated abnormally');
  end;
  NewLine(Con);
  Halt;
end;


procedure FindVolID(Drive:DriveStr);

var
  Path: PathStr;
  FoundVol: SearchRec;

begin
  if KeyPressed then Pause;
  Path := Drive + ':\'+ '*.';
  FindFirst(Path,VolumeID,FoundVol);
  while (DosError = 0) do
    begin
      if FoundVol.Attr and VolumeID <> 0 then
        begin
          PrintEntry('',FoundVol);
          Exit;
        end;
      if KeyPressed then Pause;
      FindNext(FoundVol);
    end;
    if DosError = 18 then
      begin
        NewLine(Prn);
        Write(Prn,' ':8,'Volume in drive ',DriveLetter,' has no label');
        NewLine(Prn);
      end
    else DosErrorExit;
end;


procedure SearchCurrent(Dir:PathStr;Target:TargetStr);

var
  Path: PathStr;
  FoundFile: SearchRec;

begin
  If KeyPressed then Pause;
  Path := Dir + Target;
  FindFirst(Path,
            Hidden + ReadOnly + Directory + Archive + SysFile, FoundFile);
  while (DosError = 0) do
    begin
      if (FoundFile.attr and directory = 0) or PrintingDirs then
        begin
          Inc(FoundCount);
          Inc(TotalBytes, FoundFile.Size);
          PrintEntry(Dir,FoundFile);
        end;
      If KeyPressed then Pause;
      FindNext(FoundFile);
    end; {read loop}
    if DosError <> 18 then DosErrorExit;
end;


procedure SearchSubDirs(Dir:PathStr;Target:TargetStr);
var
  FoundDir: SearchRec;
  FileSpec: PathStr;
  Path : DirStr;
begin
 If KeyPressed then Pause;
 FileSpec:= Dir + '*.';
 FindFirst(FileSpec, Hidden + ReadOnly + Directory + Archive + SysFile, FoundDir);
 while (DosError = 0) do
   begin
     with FoundDir do
       begin
         If Name[1] <> '.' then
           if Directory and Attr <> 0 then
             begin
               FSplit(FileSpec,Path,DummyName,DummyExt);
               FindFiles(Path + Name + '\' ,Target);
             end;
       end; {with FoundDir}
     if KeyPressed then Pause;
     FindNext(FoundDir);
   end; {read loop}
   If DOSError <> 18 then DosErrorExit;
end;

procedure FindFiles(Dir:PathStr;Target:TargetStr);
begin
  SearchCurrent(Dir,Target);
  SearchSubDirs(Dir,Target);
end;


begin
  InitPgm;
  GetCommand;
  FindVolID(DriveLetter);
  FindFiles(DriveLetter+':\',TargetFile);
  PrintTotals;
end.